Pascal Super Library/Pascal Super Library (CW International)(1997).bin/LIBRARY/PBLIB1/SKEL/SKELGEN.PAS

Pascal/Delphi Source File | 1994-05-03 | 9KB | 336 lines

Program SKELGen;

{$M 20000,0,50000}

uses PbMISC, PbDATA, PbOBJS, PbPARMS, PbDDL;

{
Description:  Starting point for program to generate UNITs

Author      : Howard Richoux
Date        :
Last revised: 1.05  2/18/94
Application : IBM PC and compatibles, done in Turbo Pascal 7.0
Status      : Placed in the Public Domain by HNR Software 1/29/94
Published in: none

Intended to be the starting point for future programs like DBPASGEN and BFILEGEN.

This is oriented to producing Units which are essentially OBJECTS with
  the appropriate PASCAL shell around them.

}




var OUTPUTname : string[40];  { file name for OUTPUT program }
var INPUTname : string[40];   { file name for SOURCE data }
var INPUText  : string[3];    { default file ext for SOURCE data }
var root      : string[7];    { sort of a central identifier for fields, ... }
var prefix    : string[1];    { like x or z --> "xNAME.pas" }
var UsesStr   : string;       { slipped into the USES statement }
var AncestorObject : string;  { the object this is derived from }
var CurrentObject : string;   { THIS OBJECT }
var FieldSpec     : string;   { useful "[fld1(s10,fld2(r10.2)]"  }

var OUTPT    : OUT_object_0; { Lines are output to FILE }
var L        : STRA_object;  { Lines are output to FILE }

var flds      : DDL_object;   { hold list of fields/lengths (if needed) }




{ MAIN Code }


Procedure MakePasFields;
var i,j,len,decp : integer;
    s, nam,typstr  : string;
    typ     : char;
     begin
     for j := 1 to flds.count do
          begin
          nam  := flds.ddl[j].nam;
          typ  := flds.ddl[j].typ;
          len  := flds.ddl[j].len;
          decp := flds.ddl[j].decp;
          typstr := '';
          case typ of
             'I' : typstr := 'integer;';  {integer}
             'L' : typstr := 'longint;';  {longint}
             'R' : typstr := 'real;';     {real}
             'C' : begin                  {char array}
                   if len > 1 then
                        typstr := 'array[1..'+integerstr(len,3)+'] of char;'
                   else typstr := 'char;';
                   end;
             'S' : begin                  {PASCAL string}
                   if len = 0 then len := 1;
                   if len > 1 then
                        typstr := 'string['+integerstr(len,3)+'];'
                   else typstr := 'char;';
                   end;
              else begin      {unknown}
                   typstr := '{Unknown field type ['+typ+']}';
                   len := 0;
                   end;
              end;
          L.append('          '+leftstr(nam,10)+': '+typstr);
          end;
     end;


Procedure MakeUnitStart;
var i, width   : integer;
    rtype      : char;
    tmp, tpe   : string[40];
     begin
     L.append('{SECTION ..'+prefix+Root+' }');
     L.append(' ');
     L.append('{ '+pProgID+' - hnr   '+FormatDTime+
              ', Placed in the Public Domain by HNR Software 1/94 }');
     L.append(' ');
     L.append('Unit '+prefix+Root+';');
     L.append(' ');
     L.append('INTERFACE');
     L.append(' ');
     L.append('Uses miscstuf'+UsesStr+';');
     L.append(' ');
     end;


Procedure MakeRecType;
var i, width   : integer;
    rtype      : char;
    tmp, tpe   : string;
     begin
     if FieldSpec = '' then exit;
     L.append('{SECTION .'+Root+'_record }');
     L.append('type '+Root+'_record = record ');
     MakePasFields;
     L.append('          end;');
     L.append(' ');
     end;


Procedure MakeObjectData;
     begin
     if fieldSpec = '' then exit;
     L.append('         rec       : '+Root+'_record; ');
     end;


Procedure MakeObjectInitProc(hdr : boolean);
var i, width   : integer;
    rtype      : char;
    tmp,tmp2,tpe    : string[20];
     begin
     if hdr then
          begin
          L.append('         Procedure  init     ( xyz : integer);');
          end
     else begin
          L.append(' ');
          L.append('Procedure  '+CurrentObject+'.init( xyz : integer);');
          L.append('     begin');
          L.append('     end;');
          L.append(' ');
          L.append(' ');
          end;
     end;


Procedure MakeObjectDoneProc(hdr : boolean);
var i, width   : integer;
    rtype      : char;
    tmp,tmp2,tpe    : string[20];
     begin
     if hdr then
          begin
          L.append('         Procedure  done;');
          end
     else begin
          L.append(' ');
          L.append('Procedure  '+CurrentObject+'.done;');
          L.append('     begin');
          L.append('     end;');
          L.append(' ');
          L.append(' ');
          end;
     end;



Procedure MakeObjectMethods(hdr : boolean);
var i, width   : integer;
    rtype      : char;
    tmp,tmp2,tpe    : string[20];
     begin
     if hdr then
          begin
          L.append('         Procedure  Method1;');
          end
     else begin
          L.append(' ');
          L.append('Procedure  '+CurrentObject+'.Method1;');
          L.append('     begin');
          L.append('     end;');
          L.append(' ');
          L.append(' ');
          end;
     end;



Procedure MakeObjectProcs(hdr : boolean);
     begin
     MakeObjectInitProc(hdr);
     MakeObjectMethods(hdr);
     MakeObjectDoneProc(hdr);
     end;


Procedure MakeObjectHeader;
var tmp   : string;
     begin
     L.append('{SECTION .'+Root+'_'+AncestorObject+' }');
     L.append(' ');
     tmp := 'OBJECT;';
     if AncestorObject <> '' then tmp := 'OBJECT('+AncestorObject+')';
     L.append('type  '+Root+'_'+AncestorObject+' = '+tmp);
     MakeObjectData;
     MakeObjectProcs(true);
     L.append('         end;');
     L.append(' ');
     end;


Procedure MakeImplementation;
     begin
     L.append(' ');
     L.append('{SECTION .zImplementation }');
     L.append('IMPLEMENTATION');
     L.append(' ');
     end;


Procedure MakeUnitEnd;
     begin
     L.append(' ');
     L.append('{SECTION zzInitialization }');
     L.append('      begin { initialization }');
     L.append('      end.');
     end;



{ ------------------------------------------------------------------- }

Procedure OUTSTRA(var L : STRA_object);
var i : integer;
    s : string;
     begin
     for i := 1 to L.count do
          begin
          s := L.fetchN(i);
          OUTPT.OUT(s);
          end;
     end;


Procedure MakePas;
var outfname : string[40];
     begin
     L.init(500);
     getdir(0,outfname);
     outfname := addbackslash(outfname) + Prefix + Root;
     forceext(outfname,'pas');
     writeln('Writing to [',outfname,']');
     OUTPT.LISTinit(outfname,OUT_typREWRITE);
     OUTPT.LISTopen;

     MakeUnitStart;
     MakeRecType;
     MakeObjectHeader;
     MakeImplementation;
     MakeObjectProcs(false);
     MakeUnitEnd;

     OUTSTRA(L);
     OUTPT.done;
     end;


Procedure ProcessINPUTfile;
     begin
     if fieldSpec <> '' then
          begin
          flds.init;
          FieldSpecToPbDDL(FieldSpec,flds);
          flds.dump;
          end;
     end;


Procedure DoSKELGen(OUTPUTname : string);
var fn : string[40];
     begin
     fn := OUTPUTname;
     writeln('fn ',fn);
     writeln('root= ',Root);
     ProcessINPUTfile;
     MakePas;
     end;


Procedure SKELGenInit;
     begin
     OUTPUTname := 'testunit.pas';   {Unit file to be generated}

     addparm(1,'SOURCE','');
     addparm(1,'SOURCEEXT','txt');
     addparm(1,'FILE','');
     addparm(1,'FIELDS','[fld1(s20),fld2(r10.2),fld3(i)]');
     addparm(1,'ROOT','');
     addparm(1,'PREFIX','z');
     addparm(1,'ANCESTOR','UNKNOWN_object');
     addparm(1,'USES','');

     StandardpVarsInit;

     prefix         := GetParmStr('PREFIX');
     OUTPUTname     := GetParmStr('FILE');
     INPUTname      := GetParmStr('SOURCE');
     INPUText       := GetParmStr('SOURCEEXT');
     UsesStr        := GetParmStr('USES');
     AncestorObject := GetParmStr('ANCESTOR');

     Fieldspec      := GetParmStr('FIELDS');
     Fieldspec      := UpCaseStr(FieldSpec);
     trim(FieldSpec);
     if FieldSpec[1] = '[' then RemoveEnds(FieldSpec);

     if paramcount > 0 then INPUTname := paramstr(1);

     root      := GetParmSTr('ROOT');
     if root = '' then root := FileROOTStr(INPUTName);
     root      := UpCaseStr(root);

     CurrentObject := Root + '_' + AncestorObject;
     end;


     begin
     pProgID := 'SKELGen 1.05';
     writeln(pProgID, ' - TEST code - HNR 2/94');
     SKELGenInit;
     if INPUTname <> '' then
          begin
          DoSKELGen(INPUTname);
          end
     else writeln('Without specifying a SOURCE= file, there is no point in this exercise');
     writeln('');
     end.